perm filename READRW.F4[EMS,LCS] blob
sn#722189 filedate 1983-08-02 generic text, type T, neo UTF8
C***** CALLED BY EXPAND.F4 ********
C READRW.F4
SUBROUTINE READRW
REAL LF
INTEGER TOTL
COMMON /CCC/G,CCX,CCY,DDX,DDY,SZF
C G=DISTORTAION FACTOR, CCX,CCY=DISPLACEMENT OF CENTER
C DDX,DDY=DISPLACEMENT OF ENTIRE DRAWING, SZF=DRAWING SIZE FACTOR
COMMON /XYZ/X(650),Y(650),Z(650)
COMMON TOTL,CX,CY,LF,RT,TOP,BOT
1 CALL IO(1)
SZF=1.
CALL FACTORS
CALL GETPTS(X,Y,Z,TOTL)
IF(DDY.NE.0)RETURN
C RETURN IF DOING DRAWING TRANSITION.
C READ IN ALL THE POINTS
CALL CENTER
C SET THE CENTER POINT - CX,CY
CALL SLOPES
CALL PERCNT
C JTOTL=TOTAL # OF POINTS IN OUTER LINE OF DRAWING.
2 END
SUBROUTINE RDOUTL
INTEGER TOTL,TOTOUT
COMMON TOTL,CX,CY,LF,RT,TOP,BOT,TOTOUT
COMMON /OUTL/OX(650),OY(650),OZ(650)
1 CALL IO(2)
CALL OUTPTS(OX,OY,OZ,TOTOUT)
CC CALL GETPTS(OX,OY,OZ,TOTOUT)
C READ IN OUTLINE POINTS
END
SUBROUTINE IO(N)
COMMON/NM2/NM2
10 FORMAT(' TYPE DRAWING FILE NAME '$)
11 FORMAT(' TYPE OUTLINE FILE NAME '$)
13 FORMAT(' TYPE EXPAND FILE NAME '$)
12 FORMAT(A5)
GO TO(1,2,3)N
1 TYPE 10
ACCEPT 12,NM
IF(NM.EQ.' ')NM=NMX
NMX=NM
CALL IFILE(1,NM)
RETURN
2 TYPE 11
ACCEPT 12,NMB
IF(NMB.EQ.' ')NMB=NMQ
NMQ=NMB
CALL IFILE(1,NMB)
RETURN
3 TYPE 13
ACCEPT 12,NM2
IF(NM2.EQ.' ')RETURN
CALL OFILE(20,NM2)
END
SUBROUTINE GETPTS(X,Y,Z,K)
DIMENSION X(1),Y(1),Z(1)
COMMON /CCC/G,CCX,CCY,DDX,DDY,SZF
1 FORMAT(1I,3F)
2 READ(1,1,END=99)K,A,B,Z(K)
X(K)=(A+DDX)*SZF
Y(K)=(B+DDY)*SZF
GO TO 2
99 END
SUBROUTINE OUTPTS(X,Y,Z,K)
DIMENSION X(1),Y(1),Z(1)
COMMON /CCC/G,CCX,CCY,DDX,DDY,SZF
1 FORMAT(1I,3F)
2 READ(1,1,END=99)K,A,B,Z(K)
X(K)=A
Y(K)=B
GO TO 2
99 END
SUBROUTINE CENTER
INTEGER TOTL
REAL LF
COMMON /CCC/G,CCX,CCY,DDX,DDY,SZF,DSZ
COMMON /XYZ/X(650),Y(650),Z(650)
COMMON TOTL,CX,CY,LF,RT,TOP,BOT
LF=X(1)
RT=LF
BOT=Y(1)
TOP=BOT
DO 1 K=2,TOTL
A=X(K)
IF(A.GT.RT)RT=A
IF(A.LT.LF)LF=A
A=Y(K)
IF(A.GT.TOP)TOP=A
1 IF(A.LT.BOT)BOT=A
CX=LF+(RT-LF)/2.+CCX
CY=BOT+(TOP-BOT)/2.+CCY
CX AND CY ARE CENTER OF RECTANGLE (+DISPLACEMENT)
M=CX*DSZ
N=CY*DSZ
CALL AIVECT(M,N)
CALL AVECT(M,N)
CALL DPYOUT(1)
END
SUBROUTINE SLOPES
REAL LF
INTEGER TOTL
COMMON /XYZ/X(650),Y(650),Z(650)
COMMON /S/SL(650),P(650)
COMMON TOTL,CX,CY,LF,RT,TOP,BOT
D=0
DO 1 K=1,TOTL
A=RL(X(K),Y(K))
IF(A.GT.D)D=A
C D=LONGEST LINE FROM POINT TO CENTER
P(K)=A
C AT FIRST P HOLD LENGTH OF LINE FROM POINT TO CENTER.
SL(K)=9999.
1 IF(CX.NE.X(K))SL(K)=(CY-Y(K))/(CX-X(K))
CC DO 2 K=1,TOTL
CC2 P(K)=P(K)/D
C THIS CONVERTS P TO % OF LONGEST LINE. USED IN MAKNEW
END
FUNCTION RL(X,Y)
INTEGER TOTL
COMMON TOTL,CX,CY
C FIND HYPOTENUSE
A=CX-X
B=CY-Y
RL=SQRT(A*A+B*B)
END
SUBROUTINE FACTORS
COMMON /CCC/G,CCX,CCY,DDX,DDY,SZF,DSZ
C G=DISTORTAION FACTOR, CCX,CCY=DISPLACEMENT OF CENTER
C DDX,DDY=DISPLACEMENT OF ENTIRE DRAWING, SZF=DRAWING SIZE FACTOR
1 FORMAT(' TYPE DISTORTION FACTOR (0=1) AND DPY SIZE (0=5) '$)
2 FORMAT(' TYPE DRAWING CENTER DISPLACEMENT COORDS. '$)
3 FORMAT(' TYPE ENTIRE DRAWING DISPLACEMENT COORDS. '$)
4 FORMAT(' TYPE DRAWING SIZE FACTOR (CR=1.) '$)
14 FORMAT(' TYPE % OF TRANSITION '$)
5 FORMAT(2F)
10 FORMAT(A1)
6 WRITE(5,1)
READ(5,5)G,DSZ
IF(G.EQ.0)G=1.0
IF(DSZ.EQ.0)DSZ=5.
REREAD 10,N
IF(N.EQ.'B')GO TO 6
IF(N.NE.'T')GO TO 7
TYPE 14
ACCEPT 5,CCX,CCY
C GET TRANSITION PERCENTAGES.
IF(CCY.EQ.0)CCY=CCX
DDY=1.
RETURN
7 WRITE(5,2)
READ(5,5)CCX,CCY
REREAD 10,N
IF(N.EQ.'B')GO TO 7
8 WRITE(5,3)
READ(5,5)DDX,DDY
REREAD 10,N
IF(N.EQ.'B')GO TO 8
9 WRITE(5,4)
READ(5,5)SZF
IF(SZF.EQ.0)SZF=1.
REREAD 10,N
IF(N.EQ.'B')GO TO 9
END
SUBROUTINE PERCNT
INTEGER TOTL,Q
COMMON /CCC/G,CCX,CCY,DDX,DDY,SZF
COMMON /XYZ/X(650),Y(650),Z(650)
COMMON /S/SL(650),P(650)
COMMON TOTL,CX,CY
SQA=(TOP-CY)/(LF-CX)
SQB=-SQA
C SLOPE OF DIAGONAL OF RECTANGLE
C ASSUMES FIRST CONTINUOUS LINE IS PICTURE OUTLINE
P(1)=1.
DO 100 K=2,TOTL
IF(Z(K).NE.0)GO TO 101
JTOTL=K
100 P(JTOTL)=1.
101 DO 200 K=JTOTL+1,TOTL
J=2
202 IF(HIT(J,X,Y,K,A,B).EQ.0)GO TO 201
C A,B ARE COORDS OF HIT POINT.
J=J+1
GO TO 202
201 RLN=RL(X(K),Y(K))
C GET LENGTH OF LINE FROM CX,CY TO THIS POINT
RLNB=RL(A,B)
8 H=RLN/RLNB
C H=% OF DIST. FROM CENTER TO OUTER LINE OF DRAWING.
200 P(K)=H
END